home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpmap.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  9.5 KB  |  253 lines
  1. ;;; CMPMAP  Map functions.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'mapcar 'c1mapcar 'c1)
  25. (si:putprop 'maplist 'c1maplist 'c1)
  26. (si:putprop 'mapcar 'c2mapcar 'c2)
  27. (si:putprop 'mapc 'c1mapc 'c1)
  28. (si:putprop 'mapl 'c1mapl 'c1)
  29. (si:putprop 'mapc 'c2mapc 'c2)
  30. (si:putprop 'mapcan 'c1mapcan 'c1)
  31. (si:putprop 'mapcon 'c1mapcon 'c1)
  32. (si:putprop 'mapcan 'c2mapcan 'c2)
  33.  
  34. (defun c1mapcar (args) (c1map-functions 'mapcar t args))
  35. (defun c1maplist (args) (c1map-functions 'mapcar nil args))
  36. (defun c1mapc (args) (c1map-functions 'mapc t args))
  37. (defun c1mapl (args) (c1map-functions 'mapc nil args))
  38. (defun c1mapcan (args) (c1map-functions 'mapcan t args))
  39. (defun c1mapcon (args) (c1map-functions 'mapcan nil args))
  40.  
  41. (defun c1map-functions (name car-p args &aux funob info)
  42.   (when (or (endp args) (endp (cdr args)))
  43.         (too-few-args 'map-function 2 (length args)))
  44.   (setq funob (c1funob (car args)))
  45.   (setq info (copy-info (cadr funob)))
  46.   (list name info funob car-p (c1args (cdr args) info))
  47.   )
  48.  
  49. (defun c2mapcar (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  50.   (let ((label (next-label*))
  51.         (value-loc (list 'VS (vs-push)))
  52.         (handy (list 'CVAR (next-cvar)))
  53.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  54.                                    (list 'CVAR (next-cvar)))
  55.                          args))
  56.         save
  57.         )
  58.        (setq save (save-funob funob))
  59. ;       (setq args (inline-args args
  60. ;                               (make-list (length args) :initial-element t)))
  61.        (setq args (push-changed-vars
  62.                    (inline-args args (make-list (length args)
  63.                                                 :initial-element t))
  64.                    funob))
  65.        (wt-nl "{object " handy ";")
  66.        (dolist** (loc handies)
  67.          (wt-nl "object " loc "= " (car args) ";")
  68.          (pop args))
  69.        (cond (*safe-compile*
  70.               (wt-nl "if(endp(" (car handies) ")")
  71.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  72.               (wt "){"))
  73.              (t
  74.               (wt-nl "if(" (car handies) "==Cnil")
  75.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  76.               (wt "){")))
  77.        (unwind-exit nil 'jump)
  78.        (wt "}")
  79.        (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);")
  80.        (wt-label label)
  81.        (let* ((*value-to-go* (list 'CAR (cadr handy)))
  82.               (*exit* (next-label))
  83.               (*unwind-exit* (cons *exit* *unwind-exit*)))
  84.              (c2funcall funob
  85.                (if car-p
  86.                    (mapcar
  87.                     #'(lambda (loc)
  88.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  89.                     handies)
  90.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  91.                            handies))
  92.                save)
  93.              (wt-label *exit*))
  94.        (cond (*safe-compile*
  95.               (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  96.               (dolist** (loc (cdr handies))
  97.                         (wt "||endp(" loc "=MMcdr(" loc "))"))
  98.               (wt "){"))
  99.              (t
  100.               (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  101.               (dolist** (loc (cdr handies))
  102.                         (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  103.               (wt "){")))
  104.        (unwind-exit value-loc 'jump)
  105.        (wt "}")
  106.        (wt-nl handy "=MMcdr(" handy ")=MMcons(Cnil,Cnil);")
  107.        (wt-nl) (wt-go label)
  108.        (wt "}")
  109.        (close-inline-blocks)
  110.        )
  111.   )
  112.  
  113. (defun c2mapc (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  114.   (let ((label (next-label*))
  115.         value-loc
  116.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  117.                                    (list 'CVAR (next-cvar)))
  118.                          args))
  119.         save
  120.         )
  121.        (setq save (save-funob funob))
  122. ;       (setq args (inline-args args
  123. ;                               (make-list (length args) :initial-element t)))
  124.        (setq args (push-changed-vars
  125.                    (inline-args args (make-list (length args)
  126.                                                 :initial-element t))
  127.                    funob))
  128.        (setq value-loc (car args))
  129.        (wt-nl "{")
  130.        (dolist** (loc handies)
  131.                  (wt-nl "object " loc "= " (car args) ";")
  132.                  (pop args))
  133.        (cond (*safe-compile*
  134.               (wt-nl "if(endp(" (car handies) ")")
  135.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  136.               (wt "){"))
  137.              (t
  138.               (wt-nl "if(" (car handies) "==Cnil")
  139.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  140.               (wt "){")))
  141.        (unwind-exit nil 'jump)
  142.        (wt "}")
  143.        (wt-label label)
  144.        (let* ((*value-to-go* 'trash)
  145.               (*exit* (next-label))
  146.               (*unwind-exit* (cons *exit* *unwind-exit*)))
  147.              (c2funcall funob
  148.                (if car-p
  149.                    (mapcar
  150.                     #'(lambda (loc)
  151.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  152.                     handies)
  153.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  154.                            handies))
  155.                save)
  156.              (wt-label *exit*))
  157.        (cond (*safe-compile*
  158.               (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  159.               (dolist** (loc (cdr handies))
  160.                         (wt "||endp(" loc "=MMcdr(" loc "))"))
  161.               (wt "){"))
  162.              (t
  163.               (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  164.               (dolist** (loc (cdr handies))
  165.                         (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  166.               (wt "){")))
  167.        (unwind-exit value-loc 'jump)
  168.        (wt "}")
  169.        (wt-nl) (wt-go label)
  170.        (wt "}")
  171.        (close-inline-blocks)
  172.        )
  173.   )
  174.  
  175. (defun c2mapcan (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0))
  176.   (let ((label (next-label*))
  177.         (value-loc (list 'VS (vs-push)))
  178.         (handy (list 'CVAR (next-cvar)))
  179.         (handies (mapcar #'(lambda (x) (declare (ignore x))
  180.                                    (list 'CVAR (next-cvar)))
  181.                          args))
  182.         save
  183.         )
  184.        (setq save (save-funob funob))
  185. ;       (setq args (inline-args args
  186. ;                               (make-list (length args) :initial-element t)))
  187.        (setq args (push-changed-vars
  188.                    (inline-args args (make-list (length args)
  189.                                                 :initial-element t))
  190.                    funob))
  191.        (wt-nl "{object " handy ";")
  192.        (dolist** (loc handies)
  193.                  (wt-nl "object " loc "= " (car args) ";")
  194.                  (pop args))
  195.        (cond (*safe-compile*
  196.               (wt-nl "if(endp(" (car handies) ")")
  197.               (dolist** (loc (cdr handies)) (wt "||endp(" loc ")"))
  198.               (wt "){"))
  199.              (t
  200.               (wt-nl "if(" (car handies) "==Cnil")
  201.               (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil"))
  202.               (wt "){")))
  203.        (unwind-exit nil 'jump)
  204.        (wt "}")
  205.        (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);")
  206.        (wt-label label)
  207.        (let* ((*value-to-go* (list 'cdr (cadr handy)))
  208.               (*exit* (next-label))
  209.               (*unwind-exit* (cons *exit* *unwind-exit*))
  210.               )
  211.              (c2funcall funob
  212.                (if car-p
  213.                    (mapcar
  214.                     #'(lambda (loc)
  215.                               (list 'LOCATION *info* (list 'CAR (cadr loc))))
  216.                     handies)
  217.                    (mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
  218.                            handies))
  219.                save)
  220.              (wt-label *exit*))
  221.        (cond
  222.         (*safe-compile*
  223.          (wt-nl "while(!endp(MMcdr(" handy ")))" handy "=MMcdr(" handy ");")
  224.          (wt-nl "if(endp(" (car handies) "=MMcdr(" (car handies) "))")
  225.          (dolist** (loc (cdr handies)) (wt "||endp(" loc "=MMcdr(" loc "))"))
  226.          (wt "){"))
  227.         (t
  228.          (wt-nl "while(MMcdr(" handy ")!=Cnil)" handy "=MMcdr(" handy ");")
  229.          (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil")
  230.          (dolist** (loc (cdr handies))
  231.                    (wt "||(" loc "=MMcdr(" loc "))==Cnil"))
  232.          (wt "){")))
  233.        (wt-nl value-loc "=" value-loc "->c.c_cdr;")
  234.        (unwind-exit value-loc 'jump)
  235.        (wt "}")
  236.        (wt-nl) (wt-go label)
  237.        (wt "}")
  238.        (close-inline-blocks)
  239.        )
  240.   )
  241.  
  242.  
  243. (defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob)))
  244.   (dolist (loc locs (reverse locs1))
  245.           (if (and (consp loc)
  246.                    (eq (car loc) 'VAR)
  247.                    (args-info-changed-vars (cadr loc) forms))
  248.               (let ((temp (list 'VS (vs-push))))
  249.                    (wt-nl temp "= " loc ";")
  250.                    (push temp locs1))
  251.               (push loc locs1))))
  252.  
  253.